perm filename PFORM2.PAS[PAS,SYS] blob sn#534210 filedate 1980-09-06 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00017 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002	(*contents*)
C00009 00003	 (*description and history*)
C00012 00004	(*valid switches*)
C00015 00005	(*global declarations*)
C00017 00006	VAR
C00027 00007	    (*initialization:*)  (*initprocedures,reinitialize,initialize*)
C00037 00008	    (*ccl scanner:*)     (*getdirectives[setswitch]*)
C00040 00009	    (*page control:*)    (*newpage*)
C00041 00010	    (*output procs:*)    (*block[error,writeline]*)
C00045 00011		(*scanner:*)      (*insymbol[readbuffer[readline],resword*)
C00050 00012		    (*parenthese,docomment*)
C00053 00013		    (*] insymbol*)
C00058 00014		(*parsing of declarations:*)      (*recdef[casedef,parenthese]*)
C00062 00015		(*parsing of statements:*)        (*statement[endedstats,compstat,casestat,loopstat,ifstat,labelstat,repeatstat]*)
C00073 00016		(*]block*)
C00077 00017	    (*main program*)
C00078 ENDMK
C⊗;
(*contents*)

(*page   description*)

(*01*)
(*02*)  (*$t-,r64,d-     *)             (*title page*)
(*03*)  (*description and history*)
(*04*)  (*valid switches*)
(*05*)  (*global declarations*)
(*06*)  (*var*)
(*07*)     (*initialization:*)  (*initprocedures,reinitialize,getcounts,initialize*)
(*08*)     (*ccl scanner:*)     (*getdirectives[setswitch]*)
(*09*)     (*page control:*)    (*newpage*)
(*10*)     (*output procs:*)    (*block[error,writeline]*)
(*11*)        (*scanner:*)      (*insymbol[readbuffer[readline],resword*)
(*12*)           (*parenthese,docomment,skip←e←directory*)
(*13*)           (*] insymbol*)
(*14*)        (*parsing of declarations:*)      (*recdef[casedef,parenthese]*)
(*15*)        (*parsing of statements:*)        (*statement[endedstats,compstat,casestat,loopstat,ifstat,labelstat,repeatstat]*)
(*16*)        (*]block*)
(*17*)     (*main program*)
(*$t-,r64,d-     *)             (*title page*)

(**********************************************************************
 *
 *
 *                      p f o r m
 *                      ---------
 *
 *       reformats (prettyprints) a pascal source program.
 *
 *       input:  pascal source file.      (oldsource)
 *       output: reformatted source file. (newsource)
 *
 *       default input extension: none.
 *       default output extension: .new
 *       default output file name: same as the input name, with extension .new
 *
 *       machine dependency: uses features supported by the pascal/passgo
 *       compilers for dec-10, dec-20, as implemented by armando r. rodriguez
 *       at stanford university.
 *
 *       implementor: armando r. rodriguez
 *                      p.o. box 5771
 *                      stanford, ca 94305
 *                      u.s.a.
 *
 *       distributor: j. q. johnson
 *                      lots computer facility
 *                      stanford university
 *                      stanford, ca 94305
 *                      u.s.a.
 *
 *       from an original cross-reference processor written by
 *       manuel mall, university of hamburg (1974) and distributed
 *       with the hamburg compiler for dec-10, dec-20 computers, by decus.
 *
 *
 *      part of the developement effort applied to this programs was performed
 *      as part of the effort in developement of programming languages and
 *      compilers at stanford university, under a subcontract from
 *      lawrence livermore laboratory to the computer science department, principal
 *      investigarors profs. forest baskett and john hennessy, contract no. ...
 *      lll po9628303.  the s-1 work hardware development has been supported by
 *      the  department of  the navy  via office  of naval  research  order
 *      numbers n00014-76-f-0023, n00014-77-f-0023, and n00014-78-f-0023 to  the
 *      university  of  california  lawrence  livermore  laboratory  (which   is
 *      operated for  the  u.   s.   department of  energy  under  contract  no.
 *      w-7405-eng-48), from  the  computations  group of  the  stanford  linear
 *      accelerator center (supported by the  u.  s. department of energy  under
 *      contract  no.   ey-76-c-03-0515),  and  from  the  stanford   artificial
 *      intelligence  laboratory  (which  receives  support  from  the   defense
 *      advanced research projects agency and the national science foundation).
 *
 (**********************************************************************

 (*description and history*)

(**********************************************************************
 *
 *      jul-79. armando r. rodriguez.
 *              + separate it into pform and pcref
 *              + adapt it for the lineprinter at sail.
 *              + improve the implementation of statement counts.
 *              + fix bugs.
 *
 *      mar-79. armando r. rodriguez
 *              + implement statement counts.
 *
 *      dec-78. armando r. rodriguez (stanford)
 *              + speed up and cleanning of the code.
 *              + fix small bugs.
 *
 *       jul-78. armando r. rodriguez (stanford).
 *               + improve the cross reference listing.
 *               + listing of proc-func call nesting.
 *               + report the line numbers of begin and end of body of procedures.
 *
 *       mar-78. armando r. rodriguez (stanford).
 *                       + a new set of switch options.
 *                       + some new errors are reported.
 *
 *       date unknown. larry paulson (stanford).
 *                       + make the files of type text
 *                       + not as many forced newlines.
 *                       + the report on procedure calls was cancelled.
 *
 *
 (**********************************************************************)


(*valid switches*)

(*---------------------------------------------------------------------
 !
 !  valid switches are:                     brackets indicate optional.
 !                                          <n> stands for an integer number.
 !  (defaults in parens are at sail)        <l> stands for a letter.
 !
 !  switch          meaning                                         default.
 !
 !           files.
 !   /version:<n>    behave as if conditionally compiling %<n>
 !                     comments.                                    -1
 !
 !           page and line format
 !   /indent:<n>     indentation between levels.                    4,3 (lots,sail)
 !
 !           statement format
 !   /begin:[-]<n>   if the [-] is not there, the contents of a
 !                     begin..end block is indented n spaces further.
 !                   if it is there, the block will not be indented,
 !                     but the begin and end statements will be
 !                     exdented n spaces.                           0
 !   /[no]force      forces newline in standard places. (before and
 !                    after begin, end, then, else, repeat, etc.)   off
 !
 !           upper and lower case
 !                          note: the possible values for <l> are:
 !                                  u means upper case
 !                                  l means lower case.
 !
 !   /res:<l>        case used for reserved words.                  u
 !   /nonres:<l>     same for non-reserved words.                   l
 !   /comm:<l>       same for comments.                             l (u)
 !   /str:<l>        same for strings.                              u
 !   /case:<l>       resets all the defaults to <l>.                off
 !
 +--------------------------------------------------------------------*)


(*global declarations*)


PROGRAM pform ;


CONST

    version = 'PFORM/LOTS 1.1  6-SEP-79';
    verlength = 10;
    backslash = '\';
    linsize = 600;                       (*maximum size of an input line*)
    linsizplus2 = 602;                   (*linsize + 2*)
    ht = 11B;                            (*ascii tab*)
    blanks = '          ';               (*for editing purposes*)

    linnumsize = 5;



TYPE

    pack6 = PACKED ARRAY[1..6] OF char;
    pack9 = PACKED ARRAY[1..9] OF char;
    pack15 = PACKED ARRAY[1..15] OF char;

    errkinds = (begerrinblkstr,missgend,missgthen,missgof,missgexit,
		missgrpar,missgquote,missgmain,missgpoint,linetoolong,
		missgrbrack,missguntil);

    symbol = (labelsy,constsy,typesy,varsy,programsy,             (*decsym*)
	      functionsy,proceduresy,initprocsy,                  (*prosym*)
	      endsy,untilsy,elsesy,thensy,exitsy,ofsy,dosy,eobsy, (*endsymbols*)
	      beginsy,casesy,loopsy,repeatsy,ifsy,                (*begsym*)
	      recordsy,forwardsy,gotosy,othersy,intconst,ident,strgconst,externsy,langsy,forsy,whilesy,
	      rbracket,rparent,semicolon,point,lparent,lbracket,colon,eqlsy,otherssy(*delimiter*));

    linenrty = 0..maxint;
    pagenrty = 0..maxint;

VAR


    (*                  (*input control*)
    (*                  (***************)

    bufflen,                              (*length of the current line in the input buffer*)
    buffmark,                             (*length of the already printed part of the buffer*)
    bufferptr,                            (*pointer to the next character in the buffer*)
    syleng: integer;                      (*length of the last read identifier or label*)

    (*                  (*nesting and matching control*)
    (*                  (******************************)

    level,                                (*nesting depth of the current procedure*)
    variant←level,                        (*nesting depth of variants*)
    errcount: integer;                     (*counts the errors encountered*)

    (*                  (*formatting*)
    (*                  (************)

    increment,                            (*line number increment*)
    indentbegin,                          (*indentation after a begin*)
    begexd,                               (*exdentation for begin-end pairs*)
    feed,                                 (*indentation by procedures and blocks*)
    spaces,                               (*indentation for the current line*)
    lastspaces,                           (*one-time overriding value for spaces*)
    goodversion,                          (*keeps the value of the version option*)
    pagecnt,                              (*counts the file pages*)
    maxinc,                               (*greatest allowable line number*)
    maxch,                                (*maximum length of source line in crosslist*)
    line500,                              (*to give a tty message every 500 lines*)
    linecnt : integer;                    (*counts the lines  per file page*)

    tabs: ARRAY [1:17] OF ascii;          (*a string of tabs for formatting*)

    lower : ARRAY [ascii] OF ascii;       (*to map upper to lower case if desired*)


    (*                  (*scanning*)
    (*                  (**********)

    buffer  : ARRAY [-1..linsizplus2] OF ascii;   (*input buffer*)
    (*          buffer has 2 extra positions on the left and one on the right*)

    linenb : PACKED ARRAY [1..5] OF char; (*sos-line number*)
    prog←name: alfa;                      (*name of current program*)
    sy      : alfa;                       (*last symbol read*)
    syty    : symbol;                     (*type of the last symbol read*)

    (*                  (*version system*)
    (*                  (****************)

    incondcomp: boolean;

    (*                  (*switches*)
    (*                  (**********)

    elseifing,                            (*set if the sequence else if should stay in one line*)
    debugging,                            (*set if the unprinted counts are to be reported*)
    forcing,                              (*set if then, else, do, repeat will force newline*)
    rescase,                              (*set if reserved words will upshift*)
    nonrcase,                             (*set if nonreserved words will upshift*)
    comcase,                              (*set if comments will upshift*)
    strcase,                              (*set if strings will upshift*)
    thendo,                               (*set whenever 'spaces := spaces+dofeed' is executed*)
    anyversion: boolean;                  (*set if goodversion > 9*)

    (*                  (*other controls*)
    (*                  (****************)

    notokenyet,                           (*set in each line until the first token is scanned*)
    elsehere,                             (*set while an else token is to be printed*)
    fwddecl,                              (*set true by block after 'forward', 'extern'*)
    oldspaces,                            (*set when lastspaces should be used*)
    eoline,                               (*set at end on input line*)
    programpresent,                       (*set after program encountered*)
    nobody,                               (*set if no main body is found*)
    firstpage,                            (*true before writting anything*)
    eob     : boolean;                    (*eof-flag*)
    errmsg : PACKED ARRAY[errkinds,1..40] OF char;      (*error messages*)
    ch : ascii;                           (*last read character*)

    (*                  (*sets*)
    (*                  (******)

    delsy : ARRAY [' '..'←'] OF symbol;   (*type array for delimiter characters*)
    resnum: ARRAY['A'..'['] OF integer;   (*index of the first keyword beginning with the indexed letter*)
    reslist : ARRAY [1..46] OF alfa;      (*list of the reserved words*)
    ressy   : ARRAY [1..46] OF symbol;    (*type array of the reserved words*)
    alphanum,                             (*characters from 0..9 and a..z*)
    digits : SET OF char;                 (*characters from 0..9*)
    openblocksym,                         (*symbols after which a basic block starts*)
    relevantsym,                          (*start symbols for statements and procedures*)
    prosym,                               (*all symbols which begin a procedure*)
    decsym,                               (*all symbols which begin declarations*)
    begsym,                               (*all symbols which begin compound statements*)
    endsym  : SET OF symbol;              (*all symbols which terminate  statements or procedures*)


    (*                  (*pointers and files*)
    (*                  (********************)

    old←name: pack9;          (*used to get the parameter files*)
    old←dev: pack6;
    old←prot,old←ppn: integer;
    programname,oldfileid: alfa;
    oldsource: text;

    new←name: pack9;
    new←dev: pack6;
    new←prot,new←ppn: integer;
    newfileid: alfa;
    newsource: text;


    (*initialization:*)  (*initprocedures,reinitialize,initialize*)

INITPROCEDURE;
    BEGIN (*constants*)
    elsehere := false;
    elseifing := false;
    eob := false;
    indentbegin:=0;
    begexd:=0;
    goodversion := -1;
    rescase:=true;
    nonrcase:=false;
    strcase:=true;
    nobody := false;
    anyversion := false;
    oldfileid:='OLDSOURCE ';


    feed:=4;
    comcase:=false;

    new←name:='         ';
    programname:='PFORM     ';
    newfileid:='NEWSOURCE ';
    END (*constants*);


INITPROCEDURE;
    BEGIN (*reserved words*)
    resnum['A'] :=  1;    resnum['B'] :=  3;    resnum['C'] :=  4;
    resnum['D'] :=  6;    resnum['E'] :=  9;    resnum['F'] := 13;
    resnum['G'] := 18;    resnum['H'] := 19;    resnum['I'] := 19;
    resnum['J'] := 22;    resnum['K'] := 22;    resnum['L'] := 22;
    resnum['M'] := 24;    resnum['N'] := 25;    resnum['O'] := 27;
    resnum['P'] := 30;    resnum['Q'] := 33;    resnum['R'] := 33;
    resnum['S'] := 35;    resnum['T'] := 36;    resnum['U'] := 39;
    resnum['V'] := 40;    resnum['W'] := 41;    resnum['X'] := 43;
    resnum['Y'] := 43;    resnum['Z'] := 43;    resnum['['] := 43;

    reslist[ 1] :='AND       '; ressy [ 1] := othersy;
    reslist[ 2] :='ARRAY     '; ressy [ 2] := othersy;
    reslist[ 3] :='BEGIN     '; ressy [ 3] := beginsy;
    reslist[ 4] :='CASE      '; ressy [ 4] := casesy;
    reslist[ 5] :='CONST     '; ressy [ 5] := constsy;
    reslist[ 6] :='DO        '; ressy [ 6] := dosy;
    reslist[ 7] :='DIV       '; ressy [ 7] := othersy;
    reslist[ 8] :='DOWNTO    '; ressy [ 8] := othersy;
    reslist[ 9] :='END       '; ressy [ 9] := endsy;
    reslist[10] :='ELSE      '; ressy [10] := elsesy;

    reslist[11] :='EXIT      '; ressy [11] := exitsy;
    reslist[12] :='EXTERN    '; ressy [12] := externsy;
    reslist[13] :='FOR       '; ressy [13] := forsy;
    reslist[14] :='FILE      '; ressy [14] := othersy;
    reslist[15] :='FORWARD   '; ressy [15] := forwardsy;
    reslist[16] :='FUNCTION  '; ressy [16] := functionsy;
    reslist[17] :='FORTRAN   '; ressy [17] := externsy;
    reslist[18] :='GOTO      '; ressy [18] := gotosy;
    reslist[19] :='IF        '; ressy [19] := ifsy;
    reslist[20] :='IN        '; ressy [20] := othersy;

    reslist[21] :='INITPROCED'; ressy [21] := initprocsy;
    reslist[22] :='LOOP      '; ressy [22] := loopsy;
    reslist[23] :='LABEL     '; ressy [23] := labelsy;
    reslist[24] :='MOD       '; ressy [24] := othersy;
    reslist[25] :='NOT       '; ressy [25] := othersy;
    reslist[26] :='NIL       '; ressy [26] := othersy;
    reslist[27] :='OR        '; ressy [27] := othersy;
    reslist[28] :='OF        '; ressy [28] := ofsy;
    reslist[29] :='OTHERS    '; ressy [29] := otherssy;
    reslist[30] :='PACKED    '; ressy [30] := othersy;

    reslist[31] :='PROCEDURE '; ressy [31] := proceduresy;
    reslist[32] :='PROGRAM   '; ressy [32] := programsy;
    reslist[33] :='RECORD    '; ressy [33] := recordsy;
    reslist[34] :='REPEAT    '; ressy [34] := repeatsy;
    reslist[35] :='SET       '; ressy [35] := othersy;
    reslist[36] :='THEN      '; ressy [36] := thensy;
    reslist[37] :='TO        '; ressy [37] := othersy;
    reslist[38] :='TYPE      '; ressy [38] := typesy;
    reslist[39] :='UNTIL     '; ressy [39] := untilsy;
    reslist[40] :='VAR       '; ressy [40] := varsy;

    reslist[41] :='WHILE     '; ressy [41] := whilesy;
    reslist[42] :='WITH      '; ressy [42] := othersy;
    END (*reserved words*);


INITPROCEDURE;
    BEGIN (*sets*)
    digits := ['0'..'9'];
    alphanum := ['0'..'9','A'..'Z'] (*letters or digits*);
    decsym := [labelsy,constsy,typesy,varsy,programsy];
    prosym := [functionsy..initprocsy];
    endsym := [functionsy..eobsy];      (*prosym or endsymbols*)
    begsym := [beginsy..ifsy];
    relevantsym := [labelsy..initprocsy (*decsym or prosym*),beginsy,forwardsy,externsy,eobsy];
    openblocksym := [thensy,elsesy,dosy,loopsy,repeatsy,intconst,colon,exitsy]
    END (*sets*);


INITPROCEDURE;
    BEGIN (*error messages*)
    errmsg[begerrinblkstr] := 'ERROR IN BLOCK STRUCTURE: BEGIN EXPECTED';
    errmsg[missgend      ] := 'MISSING   ''END''  STATEMENT       NUMBER ';
    errmsg[missgthen     ] := 'MISSING   ''THEN''   FOR   ''IF''    NUMBER ';
    errmsg[missgof       ] := 'MISSING    ''OF''   IN    ''CASE''   NUMBER ';
    errmsg[missgexit     ] := 'MISSING   ''EXIT''   IN   ''LOOP''   NUMBER ';
    errmsg[missgrpar     ] := 'MISSING RIGHT PARENTHESIS               ';
    errmsg[missgquote    ] := 'MISSING CLOSING QUOTE ON THIS LINE      ';
    errmsg[missgmain     ] := 'WARNING: THIS FILE HAS NO MAIN BODY     ';
    errmsg[missgpoint    ] := 'MISSING CLOSING POINT AT END OF PROGRAM.';
    errmsg[linetoolong   ] := 'LINE TOO LONG. I''M GONNA GET CONFUSED.  ';
    errmsg[missguntil    ] := 'MISSING  ''UNTIL''  FOR  ''REPEAT''  NUMBER ';
    errmsg[missgrbrack   ] := 'MISSING RIGHT BRACKET                   ';
    END (*error messages*);


PROCEDURE reinitialize;
    VAR
	lch: char;
    BEGIN (*reinitialize*)

    bufflen := 0;               buffmark := 0;                  errcount := 0;
    bufferptr := 2;             variant←level := 0;             level := 0;
    line500 := 0;               linecnt :=0;                    pagecnt := 1;

    eoline := true;             firstpage := true;               notokenyet := true;
    programpresent := false;    oldspaces := false;             incondcomp := false;

    sy := blanks;               prog←name := blanks;


    END (*reinitialize*);


PROCEDURE initialize;
    VAR
	i: integer;
    BEGIN (*initialize*)
    FOR ch := ' ' TO '←' DO
	delsy [ch] := othersy;
    delsy ['('] := lparent;
    delsy [')'] := rparent;
    delsy ['['] := lbracket;
    delsy [']'] := rbracket;
    delsy [';'] := semicolon;
    delsy ['.'] := point;
    delsy [':'] := colon;
    delsy ['='] := eqlsy;
    FOR i := -1 TO 201 DO
	buffer [i] := ' ';
    FOR i := 1 TO 17 DO
	tabs [i] := chr (ht);
    FOR ch := nul TO '@' DO
	lower[ch] := ch;
    FOR ch := 'A' TO 'Z' DO
	lower[ch] := chr (ord(ch) + 40B);
    FOR ch := '[' TO del DO
	lower[ch] := ch;
    reinitialize;
    END (*initialize*);

    (*ccl scanner:*)     (*getdirectives[setswitch]*)

PROCEDURE getdirectives;
    (* checks the presence of switches with the file names.    *)
    VAR
	brkchar: char;
	try: integer;
	fromtmp: boolean;

    PROCEDURE setswitch(opt:alfa;VAR switch:boolean);
	VAR
	    i: integer;
	BEGIN (*setswitch*)
	getoption(opt,i);
	IF i=ord('L') THEN
	    switch:=false
	ELSE
	    IF i=ord('U') THEN
		switch:=true;
	END (*setswitch*);

    BEGIN (*getdirectives*)

    getparameter(oldsource,oldfileid,programname,true);

    getstatus(oldsource,old←name,old←prot,old←ppn,old←dev);




    askfilename(new←name,new←prot,new←ppn,new←dev,newfileid,programname,false,fromtmp,brkchar);
    IF (new←name = '         ') AND (new←dev = 'DSK   ') THEN
	BEGIN
	getstatus(oldsource, new←name,old←prot,old←ppn,old←dev);
	new←name[7]:='N';
	new←name[8]:='E';
	new←name[9]:='W';
	END;
    startfile(newsource,new←name,new←prot,new←ppn,new←dev,false,newfileid,'   ');


    IF option ('VERSION   ') THEN
	BEGIN
	getoption ('VERSION   ',goodversion);
	IF goodversion > 9 THEN
	    BEGIN
	    goodversion := -1;
	    anyversion := true;
	    END;
	END;

    IF option('INDENT    ') THEN
	BEGIN
	getoption('INDENT    ',feed);
	IF feed < 0 THEN
	    feed:=4;
	END;

    IF option('BEGIN     ') THEN
	BEGIN
	getoption('BEGIN     ',indentbegin);
	IF indentbegin < 0 THEN
	    BEGIN
	    begexd:=-indentbegin;
	    indentbegin:=0;
	    END;
	END;

    forcing:=forcing OR option('FORCE     ');

    elseifing := option ('ELSEIF    ');

    IF option('CASE      ') THEN
	BEGIN
	setswitch('CASE      ',rescase);
	nonrcase:=rescase;
	comcase:=rescase;
	strcase:=rescase;
	END;

    setswitch('RES       ',rescase);
    setswitch('NONRES    ',nonrcase);
    setswitch('COMM      ',comcase);
    setswitch('STR       ',strcase);



    END (*getdirectives*);

    (*page control:*)    (*newpage*)

PROCEDURE newpage;
    BEGIN (*newpage*)
    pagecnt := pagecnt + 1;
    IF eoln (oldsource) THEN
	readln(oldsource);
    linecnt := 0;
    line500 := 0;
    IF prog←name <> blanks  THEN
	write(tty,pagecnt:3,'..');
    break(tty);
    IF firstpage THEN
	firstpage := false
    ELSE
	page(newsource);
    END (*newpage*);

    (*output procs:*)    (*block[error,writeline]*)

PROCEDURE block;
    VAR
	i: integer;
	itisaproc : boolean;        (*true when the word procedure is found*)
	lastprocname: alfa;         (*implicit stack of procedure names for the header*)


    PROCEDURE error (errnr : errkinds);
	BEGIN (*error*)
	errcount := errcount+1;
	write (newsource, '(*??* ');
	CASE errnr OF
	    begerrinblkstr: write(newsource, sy, errmsg[begerrinblkstr]);
	    missgend,  missgthen, missguntil,
	    missgexit     : write(newsource, errmsg[errnr]);
	    OTHERS        : write(newsource, errmsg[errnr]);
	    END;
	writeln(newsource,' *??*)');
	writeln(tty);
	write (tty, 'ERROR AT ', linecnt*increment: linnumsize, '/', pagecnt:2,': ');
	CASE errnr OF
	    begerrinblkstr: write(tty, sy, errmsg[begerrinblkstr]);
	    missgend,  missgthen, missguntil,
	    missgexit     :
		write(tty, errmsg[errnr]);
	    OTHERS        : write(tty, errmsg[errnr]);
	    END;
	writeln(tty);
	break (tty);
	END (*error*) ;


    PROCEDURE writeline (position (*letztes zu druckendes zeichen im puffer*): integer);
	VAR
	    ladjust,
	    i, j, maxchar: integer;    (*markiert erstes zu druckendes zeichen*)



	BEGIN (*writeline*)
	position := position - 2;
	IF position > 0 THEN
	    BEGIN
	    i := buffmark + 1;                                  (* 1. discard blanks at both ends *)
	    WHILE (buffer [i] = ' ') AND (i <= position) DO
		i := i + 1;
	    buffmark := position;
	    WHILE (buffer [position] = ' ') AND (i < position) DO
		position := position - 1;

	    IF i <= position THEN                               (* 2. if anything left, write it. *)
		BEGIN
		IF NOT oldspaces THEN
		    lastspaces := spaces;


		write (newsource, tabs:lastspaces DIV 8, ' ':lastspaces MOD 8);
		FOR j := i TO position DO
		    BEGIN
		    newsource↑ := buffer[j];
		    put(newsource);
		    END;
		writeln(newsource);


		WHILE (buffmark < bufflen) AND (buffer[buffmark] = ' ') DO      (* 3. reset pointers and flags *)
		    buffmark := buffmark + 1;
		IF buffmark < bufflen THEN
		    IF buffer[buffmark - 1] = ' ' THEN
			buffmark := buffmark - 1
		    ELSE
		ELSE
		    IF (linenb = '     ') THEN
			BEGIN
			newpage;
			END
		    ELSE
			IF (linecnt >= maxinc) THEN
			    newpage;

		END  (* if i <= position *);
	    END  (* if position > 0 *);
	lastspaces := spaces;
	oldspaces := false;
	thendo := false;
	elsehere := false;
	END (*writeline*) ;

	(*scanner:*)      (*insymbol[readbuffer[readline],resword*)

    PROCEDURE insymbol ;
	LABEL
	    1,111;
	VAR
	    i: integer;
	    incondcomp: boolean;


	PROCEDURE readbuffer;
	    (*reads a character from the input buffer*)


	    PROCEDURE readline;
		(*handles leading blanks and blank lines, reads next nonblank line
		 (without leading blanks) into buffer*)
		VAR
		    ch : char;
		    i: integer;
		BEGIN (*readline*)
		(*entered at the beginning of a line*)
		LOOP
		    WHILE eoln (oldsource) AND NOT eof (oldsource) DO
			BEGIN
			(*is this a page mark?*)
			getlinenr (oldsource,linenb);
			readln(oldsource);
			IF linenb = '     ' THEN
			    BEGIN
			    newpage;
			    END
			ELSE            (*handle blank line*)
			    BEGIN
			    line500 := line500 + 1;
			    linecnt := linecnt + 1;
			    IF line500 = 500 THEN
				BEGIN
				line500 := 0;
				write(tty,'(',linecnt:4,')');
				break(tty);
				END;
			    writeln(newsource);
			    IF linecnt >= maxinc THEN
				newpage;
			    END (*handle blank line*);
			END (*while eoln(oldsource)...*);
		EXIT IF (oldsource↑ <> ' ') OR (eof (oldsource));
		    get(oldsource);
		    END (*loop*);
		bufflen := 0;
		(*read in the line*)
		WHILE NOT eoln (oldsource) DO
		    BEGIN
		    bufflen := bufflen + 1;
		    buffer [bufflen] := oldsource↑;
		    get(oldsource);
		    END;
		IF bufflen > linsize THEN
		    BEGIN
		    error(linetoolong);
		    bufflen := linsize;
		    END
		ELSE
		    BEGIN
		    buffer[bufflen+1] := ' '; (*so we can always be one char ahead*)
		    buffer[bufflen+2] := ' ';
		    END;
		IF NOT eof (oldsource) THEN
		    BEGIN
		    getlinenr (oldsource,linenb);
		    linecnt := linecnt + 1;
		    line500 := line500 + 1;
		    IF line500 = 500 THEN
			BEGIN
			line500 := 0;
			write(tty,'(',linecnt:4,')');
			break(tty);
			END;
		    readln(oldsource);
		    END;
		bufferptr := 1;
		buffmark := 0;
		notokenyet := true;
		END (*readline*) ;

	    BEGIN (*readbuffer*)
	    (*if reading past the extra blank on the end, get a new line*)
	    IF eoline THEN
		BEGIN
		writeline (bufferptr);
		ch := ' ';
		IF eof (oldsource) THEN
		    eob := true
		ELSE
		    readline;
		END
	    ELSE
		BEGIN
		ch := buffer [bufferptr];
		bufferptr := bufferptr + 1;
		END;
	    eoline := bufferptr >= bufflen + 2;
	    END (*readbuffer*) ;

	FUNCTION resword: boolean ;
	    (*determines if the current identifier is a reserved word*)
	    VAR
		i,j: integer;
		local: boolean;

	    BEGIN (*resword*)
	    local:= false;
	    i := resnum[sy[1]];
	    WHILE (i < resnum[succ(sy[1])]) AND NOT local DO
		IF reslist[ i ] = sy THEN
		    BEGIN
		    local := true;
		    syty := ressy [i];
		    IF NOT rescase THEN
			FOR j := bufferptr - syleng - 1 TO bufferptr - 2 DO
			    buffer[j] := lower[buffer[j]];
		    END
		ELSE
		    i := i + 1;
	    resword := local;
	    END (*resword*) ;
	    (*parenthese,docomment*)

	PROCEDURE parenthese (which: symbol);
	    (*handles the formatting of parentheses, except those in variant parts of records*)
	    VAR
		oldspacesmark : integer;        (*alter zeichenvorschub bei formatierung von klammern*)
	    BEGIN (*parenthese*)
	    oldspacesmark := spaces;
	    IF NOT oldspaces THEN
		BEGIN
		oldspaces := true;
		lastspaces := spaces;
		END;
	    spaces := lastspaces + bufferptr - buffmark - 2;
	    REPEAT
		insymbol;
	    UNTIL syty IN [which,externsy..whilesy,labelsy..typesy,initprocsy..exitsy,dosy..forwardsy];
	    spaces := oldspacesmark;
	    oldspaces := true;
	    IF syty = which THEN
		insymbol
	    ELSE
		IF which = rparent THEN
		    error(missgrpar)
		ELSE
		    error(missgrbrack);
	    END (*parenthese*) ;


	PROCEDURE docomment (dellength: integer; firstch: char);

	    VAR
		oldspacesmark: integer;

	    BEGIN (* docomment *)
	    oldspacesmark := spaces;
	    IF NOT oldspaces THEN
		BEGIN
		lastspaces := spaces;
		oldspaces := true;
		END;
	    spaces := spaces + bufferptr - 2;
	    IF dellength = 2 THEN
		WHILE NOT ((ch = ')') AND (buffer[bufferptr-2] = '*')) DO
		    BEGIN
		    IF NOT comcase THEN
			buffer[bufferptr] := lower[buffer[bufferptr]];
		    readbuffer;
		    END
	    ELSE
		WHILE ch <> firstch DO
		    BEGIN
		    IF NOT comcase THEN
			buffer[bufferptr] := lower[buffer[bufferptr]];
		    readbuffer;
		    END;
	    REPEAT
		readbuffer;
	    UNTIL (ch <> ' ') OR eoline;
	    IF eoline AND notokenyet THEN
		readbuffer;
	    spaces := oldspacesmark;
	    END (*docomment*);


	    (*] insymbol*)

	BEGIN (*insymbol*)
	111:
	syleng := 0;
	WHILE (ch IN ['←','(',' ','$','?','@','%',backslash,'!']) AND NOT eob  DO
	    CASE ch OF
		'(':
		    BEGIN
		    readbuffer;
		    IF (ch = '*') THEN
			docomment (2,'*')
		    ELSE
			BEGIN
			syty := lparent;
			IF variant←level = 0 THEN
			    parenthese(rparent);
			GOTO 1;
			END;
		    END;
		'%':
		    BEGIN
		    incondcomp := false;
		    readbuffer;
		    IF NOT anyversion THEN
			WHILE ch IN digits DO
			    BEGIN
			    IF ord(ch) - ord('0') = goodversion THEN
				incondcomp := true;
			    readbuffer;
			    END;
		    IF NOT (incondcomp OR anyversion) THEN
			docomment (1,'\');
		    END;
		OTHERS:
		    readbuffer;
		END;
	CASE ch OF
	    'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
	    'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q',
	    'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y',
	    'Z':
		BEGIN
		syleng := 0;
		sy := '          ';
		REPEAT
		    syleng := syleng + 1;
		    IF syleng <= 10 THEN
			sy [syleng] := ch;
		    readbuffer;
		UNTIL NOT (ch IN (alphanum + ['←']));
		IF NOT resword THEN
		    BEGIN
		    syty := ident ;
		    IF NOT nonrcase THEN
			FOR i := bufferptr - syleng - 1 TO bufferptr - 2 DO
			    buffer[i] := lower[buffer[i]];
		    END
		END;
	    '0', '1', '2', '3', '4', '5', '6', '7', '8',
	    '9':
		BEGIN
		REPEAT
		    syleng := syleng + 1;
		    readbuffer;
		UNTIL NOT (ch IN digits);
		syty := intconst;
		IF ch = 'B' THEN
		    readbuffer
		ELSE
		    BEGIN
		    IF ch = '.' THEN
			BEGIN
			REPEAT
			    readbuffer
			UNTIL NOT (ch IN digits);
			syty := othersy; syleng := 0; (*reals can't be labels*)
			END;
		    IF ch = 'E' THEN
			BEGIN
			readbuffer;
			IF ch IN ['+','-'] THEN
			    readbuffer;
			WHILE ch IN digits DO
			    readbuffer;
			syty := othersy; syleng := 0; (*reals can't be labels*)
			END;
		    END;
		END;
	    '''':
		BEGIN
		syty := strgconst;
		REPEAT
		    REPEAT
			IF NOT strcase THEN
			    buffer[bufferptr] := lower[buffer[bufferptr]];
			readbuffer;
		    UNTIL (ch = '''') OR eob OR eoline;
		    IF ch <> '''' THEN
			error(missgquote);
		    readbuffer;
		UNTIL ch <> '''';
		END;
	    '"':
		BEGIN
		REPEAT
		    readbuffer
		UNTIL NOT (ch IN  (digits + ['A'..'F']));
		syty := intconst;
		END;
	    ' ': syty := eobsy;   (*end of file*)
	    ':': BEGIN
		readbuffer;
		IF ch = '=' THEN
		    BEGIN
		    syty := othersy;
		    readbuffer;
		    END
		ELSE
		    syty := delsy[':'];
		END;
	    '\':
		BEGIN
		readbuffer;
		IF incondcomp THEN
		    BEGIN
		    incondcomp := false;
		    GOTO 111;
		    END
		ELSE
		    syty := othersy;
		END;
	    '[':
		BEGIN
		syty := lbracket; readbuffer; parenthese(rbracket);
		END;
	    OTHERS:
		BEGIN
		syty := delsy [ch];
		readbuffer;
		END
	    END (*case ch of*);
	1:
	notokenyet := false;
	END (*insymbol*) ;

	(*parsing of declarations:*)      (*recdef[casedef,parenthese]*)

    PROCEDURE recdef;
	VAR
	    oldspacesmark  : integer;         (*alter zeichenvorschub bei formatierung von records*)


	PROCEDURE casedef;
	    VAR
		oldspacesmark  : integer;       (*alter zeichenvorschub bei formatierung von variant parts*)


	    PROCEDURE parenthese;
		(*handles the formatting of parentheses inside variant parts*)
		VAR
		    oldspacesmark : integer;      (*saved value of 'spaces'*)
		BEGIN (*parenthese*)
		oldspacesmark := spaces;
		IF NOT oldspaces THEN
		    BEGIN
		    oldspaces := true;
		    lastspaces := spaces;
		    END;
		spaces := spaces + bufferptr - 2;
		insymbol;
		REPEAT
		    CASE syty OF
			casesy  :
			    casedef;
			recordsy :
			    recdef;
			rparent: ;
			OTHERS :
			    insymbol;
			END;
		    (*until we apparently leave the declaration*)
		UNTIL syty IN [strgconst..whilesy,rparent,labelsy..exitsy,dosy..beginsy,
			       loopsy..ifsy,forwardsy];
		spaces := oldspacesmark;
		oldspaces := true;
		IF syty = rparent THEN
		    BEGIN
		    insymbol;
		    END
		ELSE
		    error(missgrpar);
		END (*parenthese*) ;

	    BEGIN (*casedef*)
	    variant←level := variant←level+1;
	    oldspacesmark := spaces;
	    IF NOT oldspaces THEN
		BEGIN
		oldspaces := true;
		lastspaces := spaces;
		END;
	    spaces := bufferptr - buffmark + lastspaces - syleng + 3;
	    insymbol;
	    REPEAT
		IF syty = lparent THEN
		    parenthese
		ELSE
		    insymbol
	    UNTIL syty IN [untilsy..exitsy,labelsy..endsy,rparent,dosy..beginsy];
	    spaces := oldspacesmark;
	    variant←level := variant←level-1;
	    END (*casedef*) ;

	BEGIN (*recdef*)
	oldspacesmark := spaces;
	IF NOT oldspaces THEN
	    BEGIN
	    oldspaces := true;
	    lastspaces := spaces;
	    END;
	spaces := bufferptr - buffmark + spaces - syleng - 2 + feed;
	insymbol;
	REPEAT
	    CASE syty OF
		casesy   : casedef;
		recordsy : recdef;
		OTHERS   : insymbol
		END;
	UNTIL syty IN [untilsy..exitsy,labelsy..endsy,dosy..beginsy];
	oldspaces := true;
	lastspaces := spaces - feed;
	spaces := oldspacesmark;
	IF syty = endsy THEN
	    BEGIN
	    insymbol;
	    END
	ELSE
	    error(missgend);
	END (*recdef*) ;

	(*parsing of statements:*)        (*statement[endedstats,compstat,casestat,loopstat,ifstat,labelstat,repeatstat]*)


    PROCEDURE statement;
	VAR
	    oldspacesmark,           (*spaces at entry of this procedure*)
	    curblocknr : integer;     (*current blocknumber*)


	PROCEDURE endedstatseq(endsym: symbol;  letter: char);
	    BEGIN
	    statement;
	    WHILE syty = semicolon DO
		BEGIN
		insymbol;
		statement;
		END;
	    WHILE NOT (syty IN [endsym,eobsy,proceduresy,functionsy]) DO
		BEGIN
		error(missgend);
		IF NOT (syty IN begsym) THEN
		    insymbol;
		statement;
		WHILE syty = semicolon DO
		    BEGIN
		    insymbol;
		    statement;
		    END;
		END;
	    IF forcing THEN
		writeline(bufferptr-syleng);
	    oldspaces := true;
	    IF (endsym = endsy) THEN
		BEGIN
		IF indentbegin = 0 THEN
		    lastspaces := max(0,spaces-begexd)
		ELSE
		    lastspaces := max(0,spaces-indentbegin);
		IF syty <> endsy THEN
		    error(missgend)
		END
	    ELSE
		BEGIN
		lastspaces := max(0,spaces - feed);
		IF syty <> endsym THEN
		    error(missguntil);
		END;
	    END (*endedstatseq*);


	PROCEDURE compstat;
	    BEGIN (*compstat*)
	    IF indentbegin = 0 THEN
		BEGIN
		IF NOT oldspaces THEN
		    BEGIN
		    oldspaces := true;
		    lastspaces := max (0,spaces-begexd)
		    END;
		END
	    ELSE
		IF NOT oldspaces THEN
		    BEGIN
		    oldspaces := true;
		    lastspaces := max (0,spaces - indentbegin);
		    END;
	    insymbol;
	    IF forcing THEN
		writeline(bufferptr-syleng);
	    endedstatseq(endsy, 'E');
	    IF syty = endsy THEN
		BEGIN
		insymbol ;
		writeline(bufferptr-syleng);
		END;
	    END (*compstat*) ;


	PROCEDURE casestat;
	    VAR
		oldspacesmark : integer;        (*saved value of 'spaces'*)

	    BEGIN (*casestat*)
	    IF NOT oldspaces THEN
		BEGIN
		oldspaces := true;
		lastspaces := max (0,spaces-feed);
		END;
	    insymbol;
	    statement;
	    IF syty = ofsy THEN
		writeline (bufferptr)
	    ELSE
		error (missgof);
	    LOOP
		REPEAT
		    REPEAT
			insymbol;
		    UNTIL syty IN [colon, functionsy .. eobsy];
		    IF syty = colon THEN
			BEGIN
			oldspacesmark := spaces;
			lastspaces := spaces;
			spaces := spaces + feed;
			(* spaces := bufferptr - buffmark + spaces - 4; *)
			oldspaces := true;
			thendo := true;
			insymbol;
			statement;
			IF syty = semicolon THEN
			    insymbol;
			spaces := oldspacesmark;
			END;
		UNTIL syty IN endsym;
	    EXIT IF syty IN [endsy,eobsy,proceduresy,functionsy];
		error (missgend);
		END;
	    writeline(bufferptr-syleng);
	    IF syty = endsy THEN
		BEGIN
		insymbol ;
		writeline(bufferptr-syleng);
		END
	    ELSE
		error (missgend);
	    END (*casestat*) ;


	PROCEDURE loopstat;
	    BEGIN (*loopstat*)
	    IF NOT oldspaces THEN
		BEGIN
		oldspaces := true;
		lastspaces := max (0,spaces - feed);
		END;
	    insymbol;
	    statement;
	    WHILE syty = semicolon DO
		BEGIN
		insymbol;
		statement;
		END;
	    IF syty = exitsy THEN
		BEGIN
		writeline(bufferptr-syleng);
		oldspaces := true;
		lastspaces := spaces-feed;
		insymbol; insymbol;
		END
	    ELSE
		error(missgexit);
	    endedstatseq(endsy, 'E');
	    IF syty = endsy THEN
		BEGIN
		insymbol ;
		writeline(bufferptr-syleng);
		END;
	    END (*loopstat*) ;


	PROCEDURE ifstat;
	    VAR
		oldspacesmark: integer;

	    BEGIN  (*ifstat*)
	    oldspacesmark := spaces;
	    IF NOT elsehere THEN
		BEGIN
		IF NOT oldspaces THEN
		    BEGIN
		    oldspaces := true;
		    lastspaces := max (0,spaces - feed);
		    END;
		(*make 'then' and 'else' line up with 'if' unless on same line*)
		spaces := lastspaces + bufferptr - buffmark + feed - 4;
		END (*if not elsehere*);
	    insymbol;
	    statement; (*will eat the expression and stop on a keyword*)
	    IF syty = thensy THEN
		BEGIN
		IF NOT oldspaces THEN
		    BEGIN
		    oldspaces := true;
		    lastspaces := max (0,spaces-feed);
		    END;
		IF forcing THEN
		    writeline(bufferptr)
		ELSE
		    thendo := true;
		(*suppress further indentation from a 'do'*)
		insymbol;
		statement;
		END
	    ELSE
		error (missgthen);
	    IF syty = elsesy THEN       (*parse the else part*)
		BEGIN
		writeline(bufferptr-syleng);
		IF NOT oldspaces THEN
		    BEGIN
		    oldspaces := true;
		    lastspaces := max (0,spaces-feed);
		    END;
		IF forcing AND NOT elseifing THEN
		    writeline(bufferptr)
		ELSE
		    thendo := true;
		elsehere := true;
		insymbol;
		statement;
		END;
	    oldspaces := true; (*preserve indentation of statement*)
	    writeline(bufferptr-syleng);
	    spaces := oldspacesmark;
	    END (*ifstat*) ;


	PROCEDURE labelstat;
	    BEGIN (*labelstat*)
	    lastspaces := level * feed;
	    oldspaces := true;
	    insymbol;
	    writeline(bufferptr-syleng);
	    END (*labelstat*) ;


	PROCEDURE repeatstat;
	    BEGIN
	    IF NOT oldspaces THEN
		BEGIN
		oldspaces := true;
		lastspaces := max (0,spaces - feed);
		END;
	    insymbol;
	    endedstatseq(untilsy, 'U');
	    IF syty = untilsy THEN
		BEGIN
		insymbol;
		statement;
		writeline(bufferptr-syleng);
		END;
	    END (*repeatstat*) ;

	BEGIN (*statement*)
	oldspacesmark := spaces; (*save the incoming value of spaces to be able to restore  it*)
	IF syty = intconst THEN
	    BEGIN
	    insymbol;
	    IF syty = colon THEN
		labelstat;
	    END;
	IF syty IN begsym THEN
	    BEGIN
	    IF NOT thendo THEN
		BEGIN
		writeline(bufferptr-syleng);
		IF (syty <> beginsy) THEN
		    spaces := spaces + feed
		ELSE
		    spaces:=spaces + indentbegin;
		END;
	    CASE syty OF
		beginsy : compstat;
		loopsy  : loopstat;
		casesy  : casestat;
		ifsy    : ifstat;
		repeatsy: repeatstat
		END;
	    END
	ELSE
	    BEGIN
	    IF forcing THEN
		IF syty IN [forsy,whilesy] THEN
		    writeline(bufferptr-syleng);
	    WHILE NOT (syty IN [semicolon,functionsy..recordsy]) DO
		insymbol;
	    IF syty = dosy THEN
		BEGIN
		IF NOT thendo THEN
		    BEGIN
		    oldspaces := true;
		    lastspaces := spaces;
		    spaces := spaces + feed;
		    IF NOT forcing THEN
			thendo := true;
		    END;
		insymbol;
		statement;
		writeline(bufferptr-syleng);
		END;
	    END;
	spaces := oldspacesmark;
	END (*statement*) ;


	(*]block*)

    BEGIN (*block*)
    REPEAT
	insymbol;
    UNTIL syty IN relevantsym;
    level := level + 1;
    spaces := level * feed;
    REPEAT
	fwddecl := false;
	WHILE syty IN decsym DO                 (*declarations: labels, types, vars*)
	    BEGIN
	    writeline(bufferptr-syleng);
	    oldspaces := true;
	    lastspaces := max(0,spaces-feed);
	    IF syty = programsy THEN
		BEGIN
		programpresent := true;
		insymbol;
		prog←name := sy;
		writeln(tty);
		write(tty,version:verlength,': ',old←name:6,' [ ',prog←name,' ] PAGE');
		FOR i := 1 TO pagecnt DO
		    write (tty, i:3,'..');
		break(tty);
		END
	    ELSE        (*syty <> programsy*)
		BEGIN
		IF forcing THEN
		    writeline(bufferptr);
		END (*syty <> programsy*);

	    REPEAT
		insymbol;
		IF syty = recordsy THEN
		    recdef;
	    UNTIL syty IN relevantsym;
	    END;
	WHILE syty IN prosym DO                 (*procedure and function declarations*)
	    BEGIN
	    writeline(bufferptr-syleng);
	    oldspaces := true;
	    lastspaces := max(0,spaces-feed);
	    IF syty <> initprocsy THEN
		insymbol;
	    block;
	    IF syty = semicolon THEN
		insymbol;
	    END (*while syty in prosym*)
	    (*forward and external declarations may come before 'var', etc.*)
    UNTIL NOT fwddecl;
    IF forcing THEN
	writeline(bufferptr-syleng);
    level := level - 1;
    spaces := level * feed;
    IF NOT (syty IN [beginsy,forwardsy,externsy,eobsy,langsy]) THEN
	BEGIN
	IF (level = 0) AND (syty = point) THEN
	    nobody := true
	ELSE
	    error (begerrinblkstr);
	WHILE NOT (syty IN [beginsy,forwardsy,externsy,eobsy,langsy,point]) DO
	    insymbol
	END;
    IF syty = beginsy THEN
	statement
    ELSE
	IF NOT nobody THEN
	    BEGIN
	    fwddecl := true;
	    insymbol;
	    END;
    IF level = 0 THEN
	IF programpresent THEN
	    BEGIN
	    IF nobody THEN
		BEGIN
		error (missgmain);
		errcount := errcount - 1;
		END;
	    IF syty <> point THEN
		error(missgpoint);
	    writeline(bufflen+2);
	    writeln(tty);
	    writeln (tty,errcount:4,' ERROR(S) DETECTED');   break(tty);
	    END (*if level = 0*);
    END (*block*) ;


    (*main program*)

BEGIN
settime;
getdirectives;
initialize;

(*find max possible line number with this increment*)
maxinc := (99999 DIV increment);
IF maxinc > 4000 THEN
    maxinc := 4000;

LOOP
    block;
EXIT IF NOT programpresent OR (syty = eobsy);
    reinitialize;
    END;


timereport(ttyoutput, '          ');


END (*pcross*).